Shareware Grab Bag/Shareware Grab Bag.iso/090/dgclpsrc.arc/DG_CLIP.PRG

Text File | 1985-08-15 | 54.0 KB | 1,970 lines

* Program..: dGENERATE
* Filename.: dg_clip.prg
* Author...: Tom Rettig
* Date.....: 6/25/85, 6/27/85, 7/25/85, 7/28/85
* Notice...: Copyright 1985, Tom Rettig Associates, All Rights Reserved.
* Version..: 1.0.c (x30)
* Run under: MS or PC DOS, any version greater than 2.0.
* Notes....: Entry into dGENERATE and main menu.
*
*
* Display copyright notice while setting up.
CLEAR
@  1,32 SAY "d G E N E R A T E"
@  3,26 SAY "Version 1.0.c  (August, 1985)"
@ 12,19 SAY "This message appears only during the time"
@ 13,19 SAY "that it takes for dGENERATE to get loaded."
@ 21,11 SAY "Copyright 1985, Tom Rettig Associates, All Rights Reserved"
@ 22,10 SAY "9300 Wilshire Boulevard, Suite 470, Beverly Hills, CA  90212"
@ 23,10 SAY "Phone:[phone] -- Source:BCR480 -- CompuServe:75066,352"
*
SET TALK OFF
*
* Check system file integrity, and exit if missing or invalid structure.
IF FILE("dg.dbf")
   USE dg
ELSE
   CLEAR
   @  3,37 SAY "Oops!"
   @  5, 9 SAY "There is no database file called 'dg.dbf' " +;
               "where I can find it,"
   @  6,20 SAY "or the structure of dg.dbf is incorrect."
   @  8, 8 SAY "dGENERATE requires a dBASE III database file " +;
               "with the structure:"
   @ 10,24 SAY "Structure for database:  dg.dbf"
   @ 11,24 SAY "Field  Field Name  Type       Width"
   @ 12,28 SAY "1  DG_TEXT     Character    254"
   @ 13,24 SAY "** Total **                     255"
   @ 16,11 SAY "Dg.dbf must be located in the default drive and directory."
   @ 20,24 SAY "Press any key to return to DOS..."
   *
   * Exit this program.
   WAIT []
   RETURN
ENDIF
*
* Set up working environment and system defaults.
*
* Initialize system variables here so they are accessible by all routines.
* Used in place of PUBLIC which has to be released explicitly by name.
STORE .F. TO dg_atget,dg_atsay,dg_blankfl,dg_char,dg_delim,dg_eol,dg_eos,;
  dg_fmemout,dg_fscrout,dg_fscr_in,dg_isdelim,dg_isfill,dg_ishelp,dg_isreltv,;
  dg_isruler,dg_init,dg_line,dg_max,dg_param,dg_rule,dg_rule1,dg_ruler,dg_wp,;
  dg_iserror
*
*
* (New system constants (dg_...) are added here and in 'config' and 'setup')
*
dg_ptest = 67
*
* Take parameters from file if they are there, or use hard coded defaults.
* IIF() parameter test is different from the one in 'generate'.
DO config WITH IIF(RECCOUNT()>0 .AND. Dg_text=[parameters: ] .AND.;
LEN(TRIM(Dg_text))>=dg_ptest .AND. SUBSTR(Dg_text,27,1)$[TF] .AND.;
SUBSTR(Dg_text,35,1)$[TF],Dg_text,;
"parameters: { } ~  80  24 F T F F T dgm dgp dgs 0 123456789. ::  61         ")
*         1  ^ ^ ^ ^2  ^   ^ ^3^ ^ ^    4         5         6    ^   ^7
*123456789.123456789.123456789.123456789.123456789.123456789.123456789.123456
*            | | | |   |   | | | | |                             |   |
*        get-' | | |   |   | | | | `-help      menu char (ascii)-'   |
*          say-' | |   |   | | | `-blank fill         word processor-'
*      init code-' |   |   | | `-delimiters
*     screen width-'   |   | |
*        screen length-'   | |
*      relative addressing-' |
*                 ruler line-'
*                             |
*   <- In screen-form file <- | -> Not in screen-form file ->
*            (1..29)          |              (30..76)
*
* Set up the screen handling and other hardware specific memvars.
dg_key = IIF("UNIX"$OS(),"RETURN","ENTER")
IF ISCOLOR()
   * Screen codes, color.
   dg_accent = [GR+/R,W/GR,GR]
   dg_normal = [GR/R ,W/GR,GR]
ELSE
   * Screen codes, mono.
   dg_accent = [W+]
   dg_normal = [W]
ENDIF
*
USE
SET BELL OFF
SET COLOR TO
SET COLOR TO &dg_normal
*
DO WHILE .T.
   CLEAR
   DO marquee WITH [   M A I N   M E N U   ]
   *
   SET COLOR TO &dg_accent
   @  7, 5 SAY "1 - <C>reate a new screen-form         " +;
               "5 - <D>OS access"
   @ 10, 5 SAY "2 - <E>dit existing screen-form        " +;
               "6 - <S>etup new parameters"
   @ 13, 5 SAY "3 - <G>enerate screen-form code        " +;
               "7 - <R>egistration information"
   @ 16, 5 SAY "4 - <M>ake memvars from fields         " +;
               "0 - <Q>uit to DOS"
   @ 23,21 SAY "Select an action by number or letter..."
   SET COLOR TO &dg_normal
   dl_i = 0
   DO key_time WITH COL()
   @ 23,21
   *
   DO CASE
      CASE CHR(dl_i) $ "Cc1"
         DO crea_new
      CASE CHR(dl_i) $ "Ee2"
         DO editor WITH []
      CASE CHR(dl_i) $ "Gg3"
         DO generate WITH []
      CASE CHR(dl_i) $ "Mm4"
         DO mem_gen
      CASE CHR(dl_i) $ "Dd5"
         DO doer WITH []
      CASE CHR(dl_i) $ "Ss6"
         DO setup
      CASE CHR(dl_i) $ "Rr7"
         DO marquee WITH [     Registration      ]
         DO helper WITH 7
      CASE CHR(dl_i) $ "Qq08"
         EXIT
      CASE dl_i = 0
         @  7, 0 CLEAR
         @ 21,23 SAY "Press any key to reactivate menu..."
         WAIT []
   ENDCASE
   *
ENDDO [WHILE .T.]
*
* Exit from dGENERATE.
CLEAR
RETURN
*
*

*** PROCEDURES: ***

PROCEDURE alt_file
* Called from generate and mem_gen, not from crea_new
PARAMETERS dl_targetf, dl_part
*
IF dl_part = 1
   * Open target file, and write its name and system date as a header.
   @ 3,0 SAY []
   SET ALTERNATE TO &dl_targetf
   SET ALTERNATE ON
   ?? "* Program..: " + dl_targetf
   ?  "* Author...: <name>"
   ?  "* Date.....: " + DTOC(DATE())
   ?  "* Notice...: Copyright " + STR(YEAR(DATE()),4) +;
                              ", <name>, All Rights Reserved."
   ?  "* Notes....: "
   ?  "*"
   ?
ELSE
   * Write footer and close the file.
   ??  "* EOF: " + dl_targetf
   CLOSE ALTERNATE
ENDIF
*
RETURN
* EOP alt_file *******************************************************


PROCEDURE config
* Called from default, generate, setup
PARAMETERS dl_linef
*
 * Characters used to denote SAYs and GETs in the screen-form.
dg_atget   = SUBSTR(dl_linef,13,1)
dg_atsay   = SUBSTR(dl_linef,15,1)
 * Character used to denote a memvar initialization in the screen-form.
dg_init    = SUBSTR(dl_linef,17,1)
 * Number of columns on the screen (1..254).
dg_eol     = VAL(SUBSTR(dl_linef,19,3))
 * Number of lines (rows) on the screen (1..999).
dg_eos     = VAL(SUBSTR(dl_linef,23,3))
 * Logicals.
dg_isreltv = SUBSTR(dl_linef,27,1) = [T]
dg_isruler = SUBSTR(dl_linef,29,1) = [T]
dg_isdelim = SUBSTR(dl_linef,31,1) = [T]
dg_isfill  = SUBSTR(dl_linef,33,1) = [T]
dg_ishelp  = SUBSTR(dl_linef,35,1) = [T]
 * Default file extensions.
dg_fmemout = SUBSTR(dl_linef,37,3)
dg_fscrout = SUBSTR(dl_linef,41,3)
dg_fscr_in = SUBSTR(dl_linef,45,3)
 * Characters in ruler.
dg_rule1   = SUBSTR(dl_linef,49,1)
dg_rule    = SUBSTR(dl_linef,51,10)
 * Delimiters.
dg_delim   = SUBSTR(dl_linef,62,2)
 * Character used in this menu (ASCII value).
dg_char    = VAL(SUBSTR(dl_linef,65,3))
 * Word processor.
dg_wp      = SUBSTR(dl_linef,69,8)
*
* Program constants.
dg_line    = REPLICATE(CHR(dg_char),80)
dg_ruler   = dg_rule1 + REPLICATE(dg_rule,INT((dg_eol-1)/10)) +;
               LEFT(dg_rule,MOD(dg_eol-1,10))
dg_max     = IIF(dg_eol < 100, 2, 3)
*
* Set the delimiters.
IF dg_isdelim .AND. dg_delim > [ ]
   SET DELIMITERS TO [&dg_delim]
   SET DELIMITERS ON
ELSE
   SET DELIMITERS OFF
ENDIF
*
* Convert logicals to character.
dl_1 = IIF(dg_isreltv, "T", "F")
dl_2 = IIF(dg_isruler, "T", "F")
dl_3 = IIF(dg_isdelim, "T", "F")
dl_4 = IIF(dg_isfill , "T", "F")
dl_5 = IIF(dg_ishelp , "T", "F")
*
* Construct a new parameters line from individual memvars.
dl = [ ]
dg_param = [parameters: ]+dg_atget+dl+dg_atsay+dl+dg_init+dl+;
  STR(dg_eol,3)+dl+STR(dg_eos,3)+dl+dl_1+dl+dl_2+dl+dl_3+dl+dl_4+dl+dl_5+dl+;
  dg_fmemout+dl+dg_fscrout+dl+dg_fscr_in+dl+dg_rule1+dl+dg_rule+dl+;
  dg_delim+dl+STR(dg_char,3)+dl+dg_wp
*
RETURN
* EOP config *********************************************************


PROCEDURE crea_new
* Called from menu
* To initialize a text file for drawing screens.
*
DO marquee WITH [ Creating a New Screen ]
*
IF dg_ishelp
   DO helper WITH 1
ENDIF
*
* Prompt for name of target text file.
dl_targetf = [ ]
dl_defext  = dg_fscr_in
dl_istargt = .T.
dl_isedit  = .F.
DO fileprmt
IF dg_iserror
   RETURN
ENDIF
*
* Prompt for name of source database file if any.
dl_sourcef = []
dl_names   = [?]
SET COLOR TO &dg_accent
*
@ 11,13 SAY "Add field and memvar names from a database file? (Y/N)" ;
        GET dl_names
IF dg_ishelp
   @ 13,08 SAY "Memory variable names are generated from "+;
               "this file's field names,"
   @ 14,14 SAY "and both are placed in the screen-form for your use."
ENDIF
*
READ
@ 11,13
@ 13,08
@ 14,14
SET COLOR TO &dg_normal
*
IF dl_names $ "Yy"
   dl_defext  = [dbf]
   STORE .F. TO dl_istargt, dl_isedit
   DO fileprmt
   IF dg_iserror
      RETURN
   ENDIF
ENDIF
*
dl_abortf = dl_targetf
DO wait_msg WITH 1
DO file_msg WITH dl_sourcef, dl_targetf
* returns with color set to dg_accent.
*
* Open target file, and write.
SET CONSOLE OFF
SET ALTERNATE TO &dl_targetf
SET ALTERNATE ON
*
* Write the top (ruler) line.
IF dg_isruler
   ?? dg_ruler
ENDIF
*
* Write the screen body.
dl_i = 1
IF dg_isfill
   DO WHILE dl_i <= dg_eos
      ? SPACE(dg_eol)
      dl_i = dl_i+1
   ENDDO
ELSE
   DO WHILE dl_i <= dg_eos
      ?
      dl_i = dl_i+1
   ENDDO
ENDIF
*
* Add parameters, date, and definition table lines.
?
? "dgDEFINE -- Begin definitions in the first column.  Example syntax follows:"
? "<definition symbol> [<memvar> " + dg_init + ;
                                 "] <expression> [PICTURE/FUNCTION <template>]"
IF [] < dl_sourcef
   USE &dl_sourcef
   dl_i = 1
   DO WHILE [] < FIELD(dl_i)
      ? [  m_] + LOWER(SUBSTR(FIELD(dl_i),1,8)) + [ ] + dg_init + [ ] +;
                 SUBSTR(FIELD(dl_i),1,1) + LOWER(SUBSTR(FIELD(dl_i),2))
      dl_i = dl_i+1
   ENDDO
   * Add file opening statement.
   ?
   ? [dgFILE], dl_sourcef
   USE
ENDIF
?
?
? "Begin options in the first column, one per line."
? "Code generating options are: dgENTRY, dgMENU, and dgREPORT, one per screen."
? "File opening option is: dgFILE <database filename>, one per screen."
?
?
? LEFT(dg_param,29) + [                       ] + DTOC(DATE())
? "            | | | |   |   | |"
? " GET Symbol-' | | |   |   | `-Ruler line (T/F)"
? " SAY Symbol---' | |   |   `---Relative Addressing (T/F)"
? " Initialization | |   `-------Form Length (rows: 1..999)"
? "         Symbol-' `-----------Form Width (columns: 1..254)"
*
CLOSE ALTERNATE
SET CONSOLE ON
SET COLOR TO &dg_normal
*
* Automatic edit with this target filename if editor is
* not memory-resident.
IF UPPER(dg_wp) # "INMEMORY"
   DO editor WITH dl_targetf
ENDIF
*
RETURN
* EOP crea_new *******************************************************


PROCEDURE doer
* Called from menu and generate
PARAMETERS dl_fname
*
DO marquee WITH [      DOS access       ]
*
IF dg_ishelp
   DO helper WITH 5
ENDIF
*
@ 3,0 SAY []
DO WHILE .T.
   ACCEPT "DOS>" TO dl_dos
   ?
   IF [] = TRIM(dl_dos)
      RETURN
   ENDIF
   RUN &dl_dos
ENDDO
*
RETURN
* EOP doer *********************************************************


PROCEDURE editor
* Called from menu and create
PARAMETERS dl_finame
*
DO marquee WITH [ Editing a Screen-Form ]
*
IF dg_ishelp
   DO helper WITH 2
ENDIF
*
* Moved in Clipper version.
IF dg_wp = [        ]
   @ 11,11 SAY "You must assign a word processor in <S>etup before editing."
   WAIT []
   RETURN
ENDIF
*
* Branch for call from menu
IF [] = dl_finame
   *
   * Prompt for name of source text file.
   dl_sourcef = [ ]
   dl_defext  = dg_fscr_in
   dl_istargt = .F.
   dl_isedit  = .T.
   DO fileprmt
   IF dg_iserror
      RETURN
   ENDIF
   dl_finame = dl_sourcef
ENDIF
*
DO file_msg WITH dl_finame, []
SET COLOR TO &dg_normal
*
* Clipper only.
IF UPPER(dg_wp) # "INMEMORY"
   RUN &dg_wp &dl_finame
   SET COLOR TO &dg_normal
ENDIF
*
* Automatic generation of edited file if
* extension is screen-form and file exists.
IF RIGHT(dl_finame,3) = dg_fscr_in .AND. FILE(dl_finame)
   DO generate WITH dl_finame
ENDIF
*
RETURN
* EOP editor *********************************************************


PROCEDURE file_msg
PARAMETERS dl_sfile, dl_tfile
* Called from crea_new, editor, generate, mem_gen
* Sets color to dg_accent on return.
@ 23,11 SAY IIF([] < dl_tfile, ;
                "Source file:               >>>  Target file: ",;
                "Source file:")
SET COLOR TO &dg_accent
@ 23,24 SAY IIF([] = dl_sfile, "<none>", dl_sfile)
@ 23,56 SAY dl_tfile
*
RETURN
* EOP file_msg *******************************************************


PROCEDURE fileprmt
* Called from crea_new, doer, editor, generate, mem_gen
* To prompt for filenames, input & output with different default extensions.
* dl_defext, dl_istargt, dl_isedit are initialized in calling routine.
* If dl_isedit, then it's ok for source file not to exist.
*
* Display files of the appropriate type.
* (file types are screen-form, executable, or database)
* System extensions (dg_f...) must be initialized in calling routine.
@ 4,0 SAY "Existing " + IIF(dl_defext=dg_fscr_in .OR. dl_defext=dg_fscrout,;
          IIF(dl_defext=dg_fscr_in,"screen-form","executable"),"database")+;
          " files in the current directory are:"
@ 5,0 SAY []
IF "UNIX" $ OS()
   DIR ALL *.&dl_defext
ELSE
   DIR *.&dl_defext/w
ENDIF
*
* Returns true if operator chooses to abort.
dg_iserror = .F.
*
DO WHILE .T.
   dl_name = [        .] + dl_defext
   SET COLOR TO &dg_accent
   @ 17,10 SAY "Enter " + IIF(dl_istargt, "target", "source") +;
               " filename, or press " + dg_key + " to abort:"
   @ 17,COL()+1 GET dl_name PICTURE [AXXXXXXXXXXX]
   READ
   *
   * Clear re-enter prompt, if any.
   @ 22,17
   @ 23,13
   *
   DO CASE
      CASE dl_name = [        .] + dl_defext
         * Abort.
         dg_iserror = .T.
         SET COLOR TO &dg_normal
         @ 17,10
         RETURN
      CASE LTRIM(dl_name) = [.] .OR. [] = dl_name
         * Invalid entry.
         @ 23,18 SAY "Invalid filename, please re-enter or abort..."
         LOOP
      CASE "." $ dl_name
         * Trim the name and place next to the extension.
         dl_name = LTRIM(RTRIM( SUBSTR(dl_name,1,AT(".",dl_name)-1) )) +;
                                SUBSTR(dl_name,AT(".",dl_name),4)
      OTHERWISE
        * Trim the name and add the default extension.
        dl_name = IIF(LEN(LTRIM(RTRIM(dl_name))) > 8,;
                      SUBSTR(LTRIM(RTRIM(dl_name)),1,8),;
                      LTRIM(RTRIM(dl_name)) ) + [.] + dl_defext
   ENDCASE
   *
   * Branch for space in filename.  Space is allowed in CASE statement
   * above in order to allow for spaces between the name and extension.
   IF [ ] $ dl_name
      @ 23,18 SAY "Invalid filename, please re-enter or abort..."
      LOOP
   ENDIF
   *
   SET COLOR TO &dg_normal
   *
   IF dl_istargt
      * It's a target file.
      *
      IF FILE(dl_name)
         SET COLOR TO &dg_accent
         @ 22,(54-LEN(dl_name))/2 SAY dl_name + " exists where I'm looking."
         @ 23,13 SAY "Press <W> to overWrite, or any other key to re-enter..."
         SET COLOR TO &dg_normal
         dl_i = 0
         DO key_time WITH COL()
         IF CHR(dl_i) $ "wW"
            dl_targetf = dl_name
            EXIT
         ELSE
            @ 17,10
            @ 22,21
            @ 23,13
            LOOP
         ENDIF
      ELSE
         dl_targetf = dl_name
         EXIT
      ENDIF
   ELSE
      * It's a source file.
      *
      IF FILE(dl_name) .OR. dl_isedit
         * It's ok for the dl_sourcef to not exist when coming from editor.
         dl_sourcef = dl_name
         SET COLOR TO &dg_normal
         EXIT
      ELSE
         SET COLOR TO &dg_accent
         @ 22,(47-LEN(dl_name))/2 ;
           SAY dl_name + " doesn't exist where I'm looking."
         @ 23,13 ;
           SAY "Please enter a different source filename, or abort..."
      ENDIF [FILE(dl_name) .OR. dl_isedit]
   ENDIF [dl_istargt]
ENDDO [WHILE .T.]
*
* Clear screen body and repaint bottom screen line before returning.
SET COLOR TO &dg_normal
@  3,0 CLEAR
@ 21,0 SAY dg_line
RETURN
*
* EOP fileprmt *******************************************************


PROCEDURE generate
* Called from menu and editor
PARAMETERS dl_filname
* Variable 'dl_filname' is used as the source file in this module.
*
DO marquee WITH [  Generating Commands  ]
*
* Branch for call from menu.
IF [] = dl_filname
   IF dg_ishelp
      DO helper WITH 3
   ENDIF
   *
   * Prompt for name of source text file.
   dl_sourcef = [ ]
   dl_defext  = dg_fscr_in
   STORE .F. TO dl_istargt, dl_isedit
   DO fileprmt
   IF dg_iserror
      RETURN
   ENDIF
   dl_filname = dl_sourcef
ENDIF
*
* Target filename is automatic from source file.
STORE SUBSTR(dl_filname,1,AT(".",dl_filname)) + dg_fscrout ;
      TO dl_tfile, dl_abortf
*
* Open system database file, and preserve the parameters line if any.
USE dg
dl_oldt = IIF(RECCOUNT()>0 .AND. Dg_text = "parameters: ",;
             TRIM(Dg_text), [] )
*
DO wait_msg WITH 1
DO file_msg WITH dl_filname, dl_tfile
*
SET SAFETY OFF
ZAP
*
* Bring source text file into database file, and index.
APPEND FROM &dl_filname SDF
INDEX ON LEFT(Dg_text,13) TO Dg_temp$
*
SET SAFETY ON
*
* Read parameters line of file, and set everything accordingly.
SEEK "parameters: "
*
* Parameter test is different from one in dg.prg.
dl_isdiffp = .F.
IF FOUND() .AND. SUBSTR(Dg_text,27,1) $ [TF] .AND.;
                 SUBSTR(Dg_text,29,1) $ [TF] .AND.;
                 SUBSTR(Dg_text,13,1) # SUBSTR(Dg_text,15,1)
   * Branch if parameters in file do not equal current system parameters.
   IF LEFT(dg_param,29) # LEFT(Dg_text,29)
      dl_isdiffp = .T.
      dl_oldp    = dg_param
      DO config WITH LEFT(Dg_text,29) + SUBSTR(dg_param,30)
   ENDIF
ELSE
   SET COLOR TO &dg_normal
   @ 22,1 SAY "Parameters line in Source file is not valid; " +;
              "current system values being used."
   SET COLOR TO &dg_accent
ENDIF
*
* Clear waiting message, open target file, and write its header.
DO wait_msg WITH 2
DO alt_file WITH dl_tfile, 1
*
* Establish offset between top of file and row zero.
* (top of screen ::= dl_offset; end of screen ::= dg_eos + dl_offset)
dl_offset = IIF(dg_isruler,2,1)
*
* If any says or gets are in the screen, prepare for the
* case where one is undefined or unitialized.
CLOSE INDEX
GO dl_offset
LOCATE WHILE RECNO() < dg_eos + dl_offset;
       FOR (dg_atget $ Dg_text .OR. dg_atsay $ Dg_text) .AND.;
           Dg_text # "parameters: " .AND. Dg_text # "<definition "
IF FOUND()
   DO line_inc
   ?? [undefined  = "***"]
   DO line_inc
ENDIF
*
* Write the file-opening command if there is one.
SET INDEX TO Dg_temp$
SEEK [dgFILE ]
dl_isfile = FOUND()
IF FOUND()
   DO line_inc
   DO line_inc
   ?? [USE ] + LTRIM(RTRIM(SUBSTR(Dg_text,AT(" ",Dg_text))))
   DO line_inc
ENDIF
*
* Write the initialized memvar statements.
SEEK [dgDEFINE]
IF FOUND()
   CLOSE INDEX
   SKIP 2
   DO WHILE [] < TRIM(Dg_text) .AND. .NOT. EOF()
      IF dg_init $ Dg_text
         dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,AT(dg_init,Dg_text)+1)))
         dl_loc = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
                                              AT(" FUNC",UPPER(dl_phrase)))
         dl_exp = IIF(dl_loc>0, TRIM(LEFT(dl_phrase,dl_loc)), dl_phrase)
         dl_var = LTRIM(SUBSTR(Dg_text,3,AT(" ",LTRIM(SUBSTR(Dg_text,3)))))
         *
         DO line_inc
         ?? dl_var + SPACE(11-LEN(dl_var)) + [= ] +;
                     IIF(TYPE("dl_exp")="U",[undefined],dl_exp)
      ENDIF
      SKIP
   ENDDO
   DO line_inc
   SET INDEX TO Dg_temp$
ENDIF
*
* Write the delimiters code if requested.
IF dg_isdelim
   DO line_inc
   ?? [SET DELIMITERS TO ] + dg_delim
   DO line_inc
ENDIF
*
* Write part one of the requested optional code.
STORE .F. TO dl_isentry, dl_ismenu, dl_isreprt
SEEK [dgENTRY ]
IF FOUND()
   dl_isentry = .T.
   DO gen_entr WITH 1
ELSE
   SEEK [dgMENU ]
   IF FOUND()
      dl_ismenu  = .T.
      dl_menupos = RECNO()
      DO gen_menu WITH 1
   ELSE
      SEEK [dgREPORT ]
      IF FOUND()
         dl_isreprt = .T.
         DO gen_rprt WITH 1
      ENDIF [report]
   ENDIF [menu]
ENDIF [entry]
*
* Write the beginning relative positioning statement.
dl_lastrow = 0
IF dg_isreltv
   DO line_inc
   ?? [@ ] + STR(dl_lastrow,dg_max) + [,] + STR(dl_lastrow,dg_max) +;
      [ SAY ""]
ENDIF
*
* Parse each line on the screen, and write the output code.
CLOSE INDEX
GO dl_offset
DO WHILE RECNO() < dg_eos+dl_offset .AND. .NOT. EOF()
   IF [] < TRIM(Dg_text)
      dl_atrow = RECNO() - dl_offset
      dl_line  = LEFT(Dg_text,dg_eol)
      * 'dl_i' is a pointer to individual characters in 'dl_line'.
      * Point to first character, skipping any spaces.
      dl_i = AT(LTRIM(dl_line), dl_line)
      DO WHILE dl_i <= dg_eol
         dl_str = SUBSTR(dl_line, dl_i)
         IF dl_str = dg_atsay .OR. dl_str = dg_atget
            * Process it as a variable.
            DO pars_var
            * Reposition record pointer which is moved to search for defines.
            GO dl_atrow + dl_offset
         ELSE
            * Process it as a literal.
            DO pars_lit
         ENDIF
         dl_lastrow = dl_atrow
      ENDDO
   ENDIF
   SKIP
ENDDO
*
DO line_inc
* Write part two of the requested optional code.
DO CASE
   CASE dl_isentry
      DO gen_entr WITH 2
   CASE dl_ismenu
      DO gen_menu WITH 2
   CASE dl_isreprt
      DO gen_rprt WITH 2
ENDCASE
*
* Write file-closing command if one was opened.
IF dl_isfile
   DO line_inc
   ?? [USE]
ENDIF
*
DO line_inc
DO line_inc
?? [WAIT ""]
*
* Close the target file.
DO line_inc
DO alt_file WITH dl_tfile, 2
*
* Restore environment.
SET COLOR TO &dg_normal
CLOSE INDEX
SET SAFETY OFF
ERASE Dg_temp$.ntx
ZAP
SET SAFETY ON
*
* Restore parameter line, and close file.
IF [] < dl_oldt
   APPEND BLANK
   REPLACE Dg_text WITH dl_oldt
ENDIF
USE
*
* Restore system parameters.
IF dl_isdiffp
   DO config WITH dl_oldp
ENDIF
*
* Automatic DO of generated file.
* Not possible in Clipper version unless generated code is compiled first.
*** DO doer WITH dl_tfile
*
RETURN
* EOP generate *******************************************************


PROCEDURE gen_entr
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
   * Part one.
   *
   DO line_inc
   ?? [* Entry algorithm]
   DO line_inc
   DO line_inc
   ?? [CLEAR]
   DO line_inc
   *
ELSE
   * Part two.
   DO line_inc
   ?? [DO WHILE .T.]
   *
   DO line_inc
   ?? [   @ 22,19 SAY "Press any key to edit, <S> to Save changes,"]
   DO line_inc
   ?? [   @ 23,18 SAY "or ] + dg_key + [ to return to menu without saving..."]
   DO line_inc
   ?? [   WAIT "" TO choice]
   DO line_inc
   ?? [   @ 22,19]
   DO line_inc
   ?? [   @ 23,18]
   *
   DO line_inc
   ?? [   DO CASE]
   DO line_inc
   ?? [      CASE "" = choice]
   DO line_inc
   ?? [         RETURN]
   DO line_inc
   ?? [      CASE "S" = UPPER(choice)]
   DO line_inc
   ?? [         * Add replace statements here.]
   DO line_inc
   ?? [         RETURN]
   DO line_inc
   ?? [      OTHERWISE]
   DO line_inc
   ?? [         READ SAVE]
   DO line_inc
   ?? [   ENDCASE]
   *
   DO line_inc
   ?? [ENDDO (WHILE .T.)]
   DO line_inc
ENDIF
*
RETURN
*
* EOP gen_entr *******************************************************


PROCEDURE gen_menu
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
   * Part one.
   *
   *
   DO line_inc
   ?? [* Menu algorithm]
   DO line_inc
   DO line_inc
   ?? [DO WHILE .T.]
   DO line_inc
   DO line_inc
   ?? [   CLEAR]
   DO line_inc
   *
ELSE
   * Part two.
   DO line_inc
   ?? [   i = 0]
   DO line_inc
   ?? [   DO WHILE i = 0]
   DO line_inc
   ?? [      i = INKEY()]
   DO line_inc
   ?? [   ENDDO]
   DO line_inc
   ?? [   *]
   DO line_inc
   ?? [   DO CASE]
   *
   * Write the specified CASE statements.
   CLOSE INDEX
   GO dl_menupos
   SKIP
   DO WHILE .NOT. ( EOF() .OR. [] = TRIM(Dg_text) )
      DO line_inc
      ?? [      CASE CHR(i) $ "] + LTRIM(RTRIM(Dg_text)) +["]
      DO line_inc
      ?? [         WAIT "Not implemented yet.  ]+;
         [Press any key to return to menu..."]
      SKIP
   ENDDO
   DO line_inc
   ?? [      CASE i = 13]
   DO line_inc
   ?? [         RETURN]
   DO line_inc
   ?? [   ENDCASE]
   DO line_inc
   DO line_inc
   ?? [ENDDO (WHILE .T.)]
ENDIF
*
RETURN
*
* EOP gen_menu ********************************************************


PROCEDURE gen_rprt
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
   * Part one.
   *
   DO line_inc
   ?? [* Report algorithm]
   DO line_inc
   DO line_inc
   ?? [* Prompt user to set up the printer or abort.]
   DO line_inc
   DO line_inc
   ?? [@ 12,23 SAY "Printing.  Please do not disturb..."]
   DO line_inc
   DO line_inc
   ?? [SET DEVICE TO PRINT]
   DO line_inc
   DO line_inc
   ?? [DO WHILE (.NOT. EOF()) .AND. "" < DBF()]
   DO line_inc
   *
ELSE
   * Part two.
   DO line_inc
   ?? [   SKIP]
   DO line_inc
   ?? [ENDDO]
   DO line_inc
   DO line_inc
   ?? [EJECT]
   DO line_inc
   ?? [SET DEVICE TO SCREEN]
   DO line_inc
   ?? [@ 12,23 SAY "  *** ***  Done Printing  *** ***  "]
ENDIF
*
RETURN
*
* EOP gen_rprt *******************************************************


PROCEDURE helper
* Called from everything that can be called from the menu, plus the menu.
* Calls the individual help screen when not called from menu.
*
PARAMETERS dl_from
* 'dl_from' is same as selection number in main menu.
*
SET COLOR TO &dg_accent
DO CASE
   CASE dl_from = 1
      DO hlp_crea
   CASE dl_from = 2
      DO hlp_edit
   CASE dl_from = 3
      DO hlp_gene
   CASE dl_from = 4
      DO hlp_mgen
   CASE dl_from = 5
      DO hlp_doer
   CASE dl_from = 6
      DO hlp_setu
   CASE dl_from = 7
      @  3,24 SAY "ARE YOU A REGISTERED dGENERATE?"
      @  5,14 SAY "For a registration fee of fifteen dollars, you get"
      @  6,13 SAY "an unprotected disk containing 3 copies of dGENERATE:"
      @  8,13 SAY "1.  The source code in two files, main and procedure"
      @  9,13 SAY "2.  A single command file coded and linked with RunTime+"
      @ 10,13 SAY "3.  A single executable file compiled with Clipper"
      @ 12, 9 SAY "Also on the disk is a text file with additional " +;
                  "documentation."
      @ 14,14 SAY "REGISTRATION ENTITLES YOU TO FULL TECHNICAL SUPPORT,"
      @ 15,12 SAY "and contributes to the development of software like this."
      @ 17,29 SAY "Tom Rettig Associates"
      @ 18,23 SAY "9300 Wilshire Boulevard, Suite 470"
      @ 19,28 SAY "Beverly Hills, CA  90212"
      @ 20,10 SAY "Phone:[phone] -- CompuServe:75066,352 "+;
                  "-- Source:BCR480"
ENDCASE
*
IF dl_from # 2
   * Only single page help screens should take this branch.
   * (Two page help screens use hlp_togl.)
   @ 23,26 SAY "Press any key to continue..."
   SET COLOR TO &dg_normal
   dl_i = 0
   DO key_time WITH COL()
ENDIF
*
* Clear help screen and repaint bottom marquee line before returning.
SET COLOR TO &dg_normal
@  3,0 CLEAR
@ 21,0 SAY dg_line
RETURN
*
* EOP helper *********************************************************


PROCEDURE hlp_crea
* Help screen for crea_new (1), called from helper
*
@ 4,0
TEXT
    1.  A target "screen-form" file is created in which you draw your screen.
         - You will be prompted for its filename, and it has a default
ENDTEXT
*
? "           extension of ." + dg_fscr_in + ;
  " if you do not specify a different one."
*
TEXT

    2.  You will be asked if you want to add names from a database file.
         - If you answer yes, you will be prompted for a database filename.
         - Memory variable names are generated from this file's field names,
           and both are placed in the screen-form for your use.

    3.  After the screen-form file is created, you are automatically placed
        in editing mode where you draw your screen with your favorite word
        processor.  Specify your own word processor by choosing number
        six <S>etup on the main menu.
ENDTEXT
*
RETURN
* EOP hlp_crea *******************************************************


PROCEDURE hlp_doer
* Help screen for doer (5), called from helper
*
@  6,0
TEXT
            1.  Under Clipper, generated dBASE III code must be
                compiled before it can be run.


            2.  This module runs any program that is executable
                directly from the DOS > prompt, including the
                Clipper compiler and linker.


            3.  Press ENTER at the DOS> prompt to return to dGENERATE.
ENDTEXT
*
RETURN
* EOP hlp_doer *******************************************************


PROCEDURE hlp_edit
* Help screen for edit (2), called from helper
*
* This initialization makes first screen come up.
dl_i      = 49
dl_screen = 2
*
DO WHILE .T.
   DO CASE
      CASE dl_screen = 2 .AND. CHR(dl_i) $ "1pP"
         *
         @ 4,0
         TEXT
   - The first (top) line is a ruler for your convenience in placing things.

   - Then there is the area where you draw your screen-form:

         ENDTEXT
         ? "           " + LEFT(dg_ruler,29) + "     " +;
                                            "<----[ruler line]"
         ?
         ? "           First name: " + dg_atsay + "1                    <--+"
         ? "            Last name: " + dg_atget +;
                                     "n____________:          |-[screen area]"
         ? "              Address: " + dg_atget + "Street_Address___:   <--+"
         TEXT
          ^          ^ ^^^               ^
          ^-Literals-^ ||^---Optional----^
                       ||
       GET/SAY Symbol--'`--Definition Symbol (expression defined below)
         ENDTEXT
         dl_screen = 1
      *
      *
      CASE dl_screen = 1 .AND. CHR(dl_i) $ "2nN"
         @ 3,0
         TEXT
   - Under the screen-form is the definition table marked by 'dgDEFINE'.
     This is where you define the symbols used in the screen-form by
     assigning them to an expression and, optionally, a variable name.

   - Anywhere below the screen-form, you can specify a code algorithm
     to be generated such as menu, entry, report, or open file.

          dgDEFINE                                <--+
          1 First_name PICTURE "AAAAAAAA"            |-[definition table]
         ENDTEXT
         ? "          n m_lname   " + dg_init +;
                                     [ Last_name FUNCTION "!"       |]
         ? "          S m_address " + dg_init +;
                                     [ SPACE(25)                 <--+]
         TEXT
                      |
                      `-------------------[memvar initialization symbol]

          dgFILE Names                            <--|-[options]
          dgENTRY                                 <--+
         ENDTEXT
         dl_screen = 2
      OTHERWISE
         RETURN
   ENDCASE
   *
   dl_i = 0
   DO hlp_togl
ENDDO
*
* EOP hlp_edit *******************************************************


PROCEDURE hlp_gene
* Help screen for generate (3), called from helper
*
@ 5,0
TEXT
       1.  When prompted, just enter the name of a screen-form file
           that you created and edited; dGENERATE will do the rest.


       2.  You can change from relative addressing (@ ROW()+1,0) to
           "hard coded" numeric coordinates (@ 5,0) in number six
           <S>etup on the main menu.


       3.  After the executable dBASE code is generated, it can be
           executed in dBASE III or compiled and executed from DOS.
ENDTEXT
*
RETURN
* EOP hlp_gene *******************************************************


PROCEDURE hlp_mgen
* Help screen for mem_gen (4), called from helper
*
@ 2,79 SAY []
TEXT
   1.  Memory variable names are generated from the file's field names.
       Only eight characters of the field name are significant in this
       operation: 'First_name' becomes 'm_first_na'.

   2.  Three sets of commands are generated using the memory variable
       names and field names from the database file.
        - The first set is composed of memory variable initialization
          statements from the file (memvar = Field).
        - The second set is composed of memory variable initialization
          statements from an expression (memvar = CTOD("  /  /  ")).
        - The third set is composed of REPLACE statements to transfer
          data from the memory variables to the file's fields
          (REPLACE Field WITH memvar).

   3.  This code is not intended to run as it stands.  It is to be
       incorporated in your program by reading it into your command file
       or procedure using your word processor.  Your program will probably
       use only some of this code, and the rest can be discarded.
ENDTEXT
*
RETURN
* EOP hlp_mgen *******************************************************


PROCEDURE hlp_setu
* Help screen for setup (6), called from helper
*
@ 5,0
TEXT
          1.  These are the system parameters that dGENERATE uses.


          2.  Information about each parameter is displayed
              when the parameter is selected.


          3.  You can change them for temporary use and still retain
              the original system defaults, or you can make your
              changes the new default.
ENDTEXT
*
RETURN
* EOP hlp_setu *******************************************************


PROCEDURE hlp_togl
* Called from hlp_edit
* For two-screen helps
*
SET COLOR TO &dg_normal
@ 22,28 SAY "This is screen number " + IIF(dl_screen=1,"one","two")
SET COLOR TO &dg_accent
@ 23,13 SAY IIF(dl_screen=1,"  2 - <N>ext screen  ","1 - <P>revious screen")-;
            ", or any other key to continue..."
*
* 'dl_i' and 'dl_screen' are initialized in the calling program.
SET COLOR TO &dg_normal
DO key_time WITH IIF(dl_screen=2,COL(),COL()-2)
*
@  3,0 CLEAR
@ 21,0 SAY dg_line
SET COLOR TO &dg_accent
RETURN
* EOP hlp_togl *******************************************************


PROCEDURE key_time
* Called from main, fileprmt, helper, hlp_togl, setup
* Also see marquee.
PARAMETERS dl_column
*
dl_j = 0
* 'dl_i' must be initialized to zero in calling program.
DO WHILE dl_i = 0
   @  1,53 SAY IIF(VAL(TIME())<12, TIME() + " am",;
                   IIF(VAL(TIME())=12, TIME() + " pm",;
                       STR(VAL(TIME())-12,2) + SUBSTR(TIME(),3) + " pm"))
   @ 23,dl_column SAY []
   *
   * Wait for a keypress or the time to change.
   dl_t = TIME()
   DO WHILE dl_t = TIME() .AND. dl_i = 0
      dl_i = INKEY()
   ENDDO
   *
   * Time out after <n> seconds.
   dl_j = dl_j+1
   IF dl_j = 180
      RETURN
   ENDIF
ENDDO
*
RETURN
* EOP key_time *******************************************************


PROCEDURE line_inc
* Called from crea_new, generate, gen_entr,
*             gen_menu, gen_rprt, mem_gen, writer
* Call before writing output statements when they are displayed on screen.
* Furnishes the carriage return before each line and tests for new screen.
*
?
IF ROW() # 21
   RETURN
ENDIF
*
@  3,0
@  4,0
@  5,0
@  6,0
@  7,0
@  8,0
@  9,0
@ 10,0
@ 11,0
@ 12,0
@ 13,0
@ 14,0
@ 15,0
@ 16,0
@ 17,0
@ 18,0
@ 19,0
@ 20,0
@  3,0 SAY []
*
RETURN
* EOP line_inc *******************************************************


PROCEDURE marquee
* Called from crea_new, doer, editor, generate, helper, mem_gen, setup
* Expects color to be dg_dim.  Also see key_time.
*
PARAMETERS dl_title
* LEN(dl_title) must be 23
*
CLEAR
@  1, 0 SAY [d G E N E R A T E   -  -] + dl_title + [-  -               -  -]
@  1,53 SAY IIF(VAL(TIME())<12, TIME() + " am",;
                IIF(VAL(TIME())=12, TIME() + " pm",;
                    STR(VAL(TIME())-12,2) + SUBSTR(TIME(),3) + " pm"))
@  1,72 SAY DATE()
@  2, 0 SAY dg_line
@ 21, 0 SAY dg_line
RETURN
* EOP marquee *********************************************************


PROCEDURE mem_gen
* Called from menu
*
CLEAR
DO marquee WITH [   Generating Memvars  ]
*
IF dg_ishelp
   DO helper WITH 4
ENDIF
*
* Prompt for name of source database file.
* (target file name is constructed from this)
dl_sourcef = [ ]
dl_defext  = [dbf]
STORE .F. TO dl_istargt, dl_isedit
DO fileprmt
IF dg_iserror
   RETURN
ENDIF
*
* Target filename is automatic from source file.
STORE SUBSTR(dl_sourcef,1,AT(".",dl_sourcef)) + dg_fmemout ;
      TO dl_tgfile, dl_abortf
*
DO wait_msg WITH 1
DO file_msg WITH dl_sourcef, dl_tgfile
*
* Copy to a structure-extended file to get the field specs.
USE &dl_sourcef
SET SAFETY OFF
COPY TO Dg_temp$ STRUCTURE EXTENDED
USE Dg_temp$
*
* Convert field names to lowercase.
REPLACE ALL Field_name WITH LOWER(Field_name)
*
* Index the structure file.
INDEX ON Field_type + Field_name TO Dg_temp$
SET SAFETY ON
*
DO wait_msg WITH 2
*
* Open target file, and write its header.
DO alt_file WITH dl_tgfile, 1
*
* Output the initialization statements from expressions.
DO line_inc
?? [* Initialization commands from expressions.]
dl_zeros = "00000000000000000000"
*
* Clipper only: needs go top after indexing
GO TOP
DO WHILE .NOT. EOF()
   DO line_inc
   DO CASE
      CASE Field_type = "C"
         ?? [m_] + SUBSTR(Field_name,1,8) + [ = SPACE(] +;
                   STR(Field_len,3) + [)]
      CASE Field_type = "D"
         ?? [m_] + SUBSTR(Field_name,1,8) + [ = CTOD("  /  /  ")]
      CASE Field_type = "L"
         ?? [m_] + SUBSTR(Field_name,1,8) + [ = .F.]
      CASE Field_type = "N" .AND. Field_dec = 0
         ?? [m_] + SUBSTR(Field_name,1,8) + [ = ] +;
                   SUBSTR(dl_zeros,1,Field_len-Field_dec)
      CASE Field_type = "N" .AND. Field_dec > 0
         ?? [m_] + SUBSTR(Field_name,1,8) + [ = ] +;
                   SUBSTR(dl_zeros,1,Field_len-Field_dec-1) + [.] +;
                   SUBSTR(dl_zeros,1,Field_dec)
   ENDCASE
   *
   SKIP
ENDDO
*
* Output the initialization statements from file fields.
DO line_inc
DO line_inc
?? [* Initialization commands from fields.]
GO TOP
DO WHILE .NOT. EOF()
   DO line_inc
   ?? [m_] + SUBSTR(Field_name,1,8) + [ = ] + ;
      UPPER(SUBSTR(Field_name,1,1)) + SUBSTR(Field_name,2,9)
   SKIP
ENDDO
*
* Output the REPLACE statements.
DO line_inc
DO line_inc
?? [* Replace commands.]
GO TOP
DO WHILE .NOT. EOF()
   DO line_inc
   ?? [REPLACE ] + UPPER(SUBSTR(Field_name,1,1)) + SUBSTR(Field_name,2,9) +;
      [ WITH m_] + SUBSTR(Field_name,1,8)
   SKIP
ENDDO
*
* Close the target file.
DO line_inc
DO line_inc
DO alt_file WITH dl_tgfile, 2
*
* Restore the environment, and return to menu.
USE
ERASE Dg_temp$.dbf
ERASE Dg_temp$.ntx
SET COLOR TO &dg_normal
RETURN
* EOP mem_gen ********************************************************


PROCEDURE pars_lit
* Called from generate
*
* It's a literal prompt; save the pointer (dl_i) and
* reposition it to the next dg_atget, dg_atsay, or eol.
dl_start   = dl_i
dl_nextsay = AT(dg_atsay,dl_str)
dl_nextget = AT(dg_atget,dl_str)
DO CASE
   CASE dl_nextsay + dl_nextget = 0
      * Point past end-of-line.
      dl_i = dg_eol+1
   CASE dl_nextsay = 0
      * Point to next dg_atget symbol.
      dl_i = dl_i-1 + dl_nextget
   CASE dl_nextget = 0
      * Point to next dg_atsay symbol.
      dl_i = dl_i-1 + dl_nextsay
   OTHERWISE
      * Point to next dg_atsay or dg_atget symbol, whichever is first.
      dl_i = dl_i-1 + IIF(dl_nextsay < dl_nextget, dl_nextsay, dl_nextget)
ENDCASE
*
* Write the literal prompt, trimming any trailing blanks.
DO writer WITH TRIM( SUBSTR(dl_line,dl_start,dl_i-dl_start) ),;
              dl_start, .T., .T.
*
RETURN
* EOP pars_lit *******************************************************


PROCEDURE pars_var
* Called from generate
*
* Activate index file for searching the variable definitions table.
SET INDEX TO Dg_temp$
*
* See if the next character is listed in the definitions table.
SEEK SUBSTR(dl_str, 2, 1) + [ ]
DO CASE
   CASE FOUND() .AND. dg_init $ Dg_text
      * If it is an initialized memvar, the expression has been tested.
      * Write the @...SAY or @...GET variable name and the
      * picture or function clause if any.
      dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,3)))
      dl_loc    = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
                                               AT(" FUNC",UPPER(dl_phrase)))
      DO writer WITH TRIM(LEFT(dl_phrase,AT(dg_init,dl_phrase)-1))+;
       IIF(dl_loc>0,IIF("PICT"$UPPER(dl_phrase)," PICTURE "," FUNCTION ")+;
       LTRIM(SUBSTR(dl_phrase,dl_loc+AT([ ],SUBSTR(dl_phrase,dl_loc+1)))),;
       []), dl_i, dl_str=dg_atsay, .F.
   CASE FOUND() .AND. .NOT. dg_init $ Dg_text
      * If defined, but not initialized, it's an expression.
      * Test the expression and write it or the 'undefined' variable.
      * Expression test is duplicated in generate.
      dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,3)))
      dl_loc    = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
                                         AT(" FUNC",UPPER(dl_phrase)))
      *
      * Uninitialized variable name will get through as valid
      * character expression.  Necessary to let field names through.
      DO writer WITH ;
           IIF(TYPE("IIF(dl_loc>0,LEFT(dl_phrase,dl_loc),dl_phrase)")="U",;
               [undefined],dl_phrase), dl_i, dl_str=dg_atsay, .F.
   OTHERWISE
      * Not defined at all, write the memvar 'undefined'.
      DO writer WITH [undefined], dl_i, dl_str=dg_atsay, .F.
ENDCASE
*
* Point to next character if there is one, or past eol.
* TRIM() added to work with LTRIM function in Clipper.
dl_i = IIF(AT(LTRIM(SUBSTR(dl_line,dl_i-1+AT(" ",TRIM(dl_str))) ),;
        dl_str) > 0 .AND. AT(" ",TRIM(dl_str)) > 0, ;
        dl_i-1 + AT( LTRIM( SUBSTR(dl_line,dl_i-1+AT(" ",dl_str)) ), dl_str),;
        dg_eol+1)
*
CLOSE INDEX
RETURN
* EOP pars_var *******************************************************


PROCEDURE setup
* Called from menu
DO marquee WITH [  Setting Up dGENERATE ]
*
IF dg_ishelp
   DO helper WITH 6
ENDIF
*
* SAYs.
dg_p1  = "Characters used to denote GETs:  and SAYs:"
dg_p2  = "Character used for the initialization code:"
dg_p3  = "Size of screen-form in ROWs:    and COLumns:"
dg_p4  = "Relative Addressing?:"
dg_p5  = "Ruler line in screen-form?:"
dg_p6  = "Delimiters on?:"
dg_p7  = "Fill screen-form with blanks?:"
dg_p8  = "Help screens on?:"
dg_p9  = "Default file extensions for drawing screens:   , code generated:"
dg_p10 = "memvar names generated:"
dg_p11 = "Characters used to make up ruler in COLumn zero: , every ten:"
dg_p12 = "Characters used for left and right delimiters:"
dg_p13 = "Character used for marquee lines in this program (ASCII value):"
dg_p14 = "Filename of word processor used for editing screen-forms:"
*
* GETs.
dl_atget   = dg_atget
dl_atsay   = dg_atsay
dl_init    = dg_init
dl_eol     = dg_eol
dl_eos     = dg_eos
dl_isreltv = dg_isreltv
dl_isruler = dg_isruler
dl_isdelim = dg_isdelim
dl_isfill  = dg_isfill
dl_ishelp  = dg_ishelp
dl_fmemout = dg_fmemout
dl_fscrout = dg_fscrout
dl_fscr_in = dg_fscr_in
dl_rule1   = dg_rule1
dl_rule    = dg_rule
dl_delim   = dg_delim
dl_char    = dg_char
dl_wp      = dg_wp
*
SET COLOR TO &dg_accent
@  3, 1 SAY "<A> -->"
@  4, 1 SAY "<B> -->"
@  5, 1 SAY "<C> -->"
@  7, 1 SAY "<D> -->"
@  8, 1 SAY "<E> -->"
@  9, 1 SAY "<F> -->"
@ 10, 1 SAY "<G> -->"
@ 11, 1 SAY "<H> -->"
@ 13, 1 SAY "<I> -->"
@ 16, 1 SAY "<J> -->"
@ 18, 1 SAY "<K> -->"
@ 19, 1 SAY "<L> -->"
@ 20, 1 SAY "<M> -->"
*
SET COLOR TO &dg_normal
@  3, 9 SAY dg_p1
@  4, 9 SAY dg_p2
@  5, 9 SAY dg_p3
@  7, 9 SAY dg_p4
@  8, 9 SAY dg_p5
@  9, 9 SAY dg_p6
@ 10, 9 SAY dg_p7
@ 11, 9 SAY dg_p8
@ 13, 9 SAY dg_p9
@ 14,50 SAY dg_p10
@ 16, 9 SAY dg_p11
@ 18, 9 SAY dg_p12
@ 19, 9 SAY dg_p13
@ 20, 9 SAY dg_p14
*
* If delimiters are being used in screens, don't use them here.
IF dg_isdelim
   SET DELIMITERS OFF
ENDIF
*
@  3,40 GET dl_atget
@  3,51 GET dl_atsay
@  4,52 GET dl_init
@  5,37 GET dl_eos PICTURE "###"
@  5,53 GET dl_eol PICTURE "###"
@  7,30 GET dl_isreltv
@  8,36 GET dl_isruler
@  9,24 GET dl_isdelim
@ 10,39 GET dl_isfill
@ 11,26 GET dl_ishelp
@ 13,53 GET dl_fscr_in
@ 13,73 GET dl_fscrout
@ 14,73 GET dl_fmemout
@ 16,57 GET dl_rule1
@ 16,70 GET dl_rule
@ 18,55 GET dl_delim
@ 19,72 GET dl_char PICTURE "###"
@ 20,66 GET dl_wp
*
CLEAR GETS
SET BELL ON
*
DO WHILE .T.
   SET COLOR TO &dg_accent
   @ 22,8 SAY "Choose item to change by letter, "+;
              "<T> to use these <T>emporarily,"
   @ 23,8 SAY "<S> to <S>ave as system defaults, or " + dg_key +;
              " to abort any changes."
   SET COLOR TO &dg_normal
   *
   dl_i = 0
   DO key_time WITH COL()
   @ 22,8
   @ 23,8
   *
   SET COLOR TO &dg_accent
   dl_istrap = .T.
   *
   * Split up to speed up an otherwise very long DO CASE structure.
   DO CASE
      CASE LOWER(CHR(dl_i)) >= 'a' .AND. LOWER(CHR(dl_i)) <= 'd'
         DO set_if1
      CASE LOWER(CHR(dl_i)) >= 'e' .AND. LOWER(CHR(dl_i)) <= 'i'
         Do set_if2
      CASE LOWER(CHR(dl_i)) >= 'j' .AND. LOWER(CHR(dl_i)) <= 'm'
         Do set_if3
      CASE CHR(dl_i) $ "tsTS" .OR. dl_i = 13 .OR. dl_i = 0
         EXIT
   ENDCASE
   @ 22,0
   @ 23,0
ENDDO [WHILE .T.]
*
* Exit routine.
IF dl_i # 13 .AND. dl_i # 0
   @ 23,27 SAY "Saving these parameters..."
   *
   * Write a new dg_param line.
   dl    = [ ]
   dl_re = IIF(dl_isreltv, "T", "F")
   dl_ru = IIF(dl_isruler, "T", "F")
   dl_d  = IIF(dl_isdelim, "T", "F")
   dl_f  = IIF(dl_isfill , "T", "F")
   dl_h  = IIF(dl_ishelp , "T", "F")
DO config WITH [parameters: ]+dl_atget+dl+dl_atsay+dl+dl_init+dl+;
 STR(dl_eol,3)+dl+STR(dl_eos,3)+dl+dl_re+dl+dl_ru+dl+dl_d+dl+dl_f+dl+dl_h+dl+;
 dl_fmemout+dl+dl_fscrout+dl+dl_fscr_in+dl+dl_rule1+dl+dl_rule+dl+;
 dl_delim+dl+STR(dl_char,3)+dl+dl_wp
   *
   * Branch to make these the system defaults.
   IF CHR(dl_i) $ "sS"
      USE dg
      IF RECCOUNT() = 0
         APPEND BLANK
      ENDIF
      REPLACE Dg_text WITH dg_param
      USE
   ENDIF (save to file)
ENDIF (save temporarily)
*
* If delimiters are being used in screens, turn them back on.
IF dg_isdelim
   SET DELIMITERS ON
ENDIF
*
SET COLOR TO &dg_normal
SET BELL OFF
RETURN
*
* EOP setup **********************************************************


PROCEDURE set_if1
* Called from setup
*
DO CASE
   CASE CHR(dl_i) $ [aA]
      @  3, 9 SAY dg_p1
      @ 22,18 SAY "GET and SAY must each use different symbols."
      @ 23, 6 SAY "Neither symbol may be used in a "+;
                  "literal prompt in the screen-form..."
      DO WHILE dl_istrap
         @  3,40 GET dl_atget
         @  3,51 GET dl_atsay
         READ
         dl_istrap = dl_atget = [ ] .OR. dl_atsay = [ ] .OR.;
                     dl_atget = dl_atsay
      ENDDO
      SET COLOR TO &dg_normal
      @  3, 9 SAY dg_p1
      @  3,40 GET dl_atget
      CLEAR GETS
   CASE CHR(dl_i) $ [bB]
      @  4, 9 SAY dg_p2
      @ 23, 8 SAY "Initialization symbol cannot be any of " +;
                  "these: []<>()`'^*/+-|:.&= "
      DO WHILE dl_istrap
         @  4,52 GET dl_init
         READ
         dl_istrap = dl_init $ "[]<>()`'^*/+-|:.&= "
      ENDDO
      SET COLOR TO &dg_normal
      @  4, 9 SAY dg_p2
   CASE CHR(dl_i) $ [cC]
      @  5, 9 SAY dg_p3
      @  5,37 GET dl_eos PICTURE "###" RANGE 1,999
      @  5,53 GET dl_eol PICTURE "###" RANGE 1,254
      @ 23,18 SAY "Range for ROWs: 1..999, and COLumns: 1..254."
      READ
      SET COLOR TO &dg_normal
      @  5, 9 SAY dg_p3
      @  5,37 GET dl_eos PICTURE "###" RANGE 1,999
      CLEAR GETS
   CASE CHR(dl_i) $ [dD]
      @  7, 9 SAY dg_p4
      @  7,30 GET dl_isreltv
      @ 23,26 SAY "Can be True/Yes or False/No."
      READ
      SET COLOR TO &dg_normal
      @  7, 9 SAY dg_p4
ENDCASE
*
RETURN
* EOP set_if1 ********************************************************


PROCEDURE set_if2
* Called from setup
*
DO CASE
   CASE CHR(dl_i) $ [eE]
      @  8, 9 SAY dg_p5
      @  8,36 GET dl_isruler
      @ 23,26 SAY "Can be True/Yes or False/No."
      READ
      SET COLOR TO &dg_normal
      @  8, 9 SAY dg_p5
   CASE CHR(dl_i) $ [fF]
      @  9, 9 SAY dg_p6
      @  9,24 GET dl_isdelim
      @ 23,26 SAY "Can be True/Yes or False/No."
      READ
      SET COLOR TO &dg_normal
      @  9, 9 SAY dg_p6
   CASE CHR(dl_i) $ [gG]
      @ 10, 9 SAY dg_p7
      @ 10,39 GET dl_isfill
      @ 23,26 SAY "Can be True/Yes or False/No."
      READ
      SET COLOR TO &dg_normal
      @ 10, 9 SAY dg_p7
   CASE CHR(dl_i) $ [hH]
      @ 11, 9 SAY dg_p8
      @ 11,26 GET dl_ishelp
      @ 23,26 SAY "Can be True/Yes or False/No."
      READ
      SET COLOR TO &dg_normal
      @ 11, 9 SAY dg_p8
   CASE CHR(dl_i) $ [iI]
      @ 13, 9 SAY dg_p9
      @ 14,50 SAY dg_p10
      @ 22,17 SAY "Each file type must use a different extension."
      @ 23,17 SAY "Extensions cannot begin with a blank or a dot."
      DO WHILE dl_istrap
         @ 13,53 GET dl_fscr_in
         @ 13,73 GET dl_fscrout
         @ 14,73 GET dl_fmemout
         READ
         dl_istrap = dl_fscr_in=dl_fscrout .OR. dl_fscr_in=dl_fmemout .OR.;
                     dl_fscrout=dl_fmemout .OR. LEFT(dl_fscr_in,1)$[. ] .OR.;
                     LEFT(dl_fscrout,1)$[. ] .OR. LEFT(dl_fmemout,1)$[. ]
      ENDDO
      SET COLOR TO &dg_normal
      @ 13, 9 SAY dg_p9
      @ 13,53 GET dl_fscr_in
      @ 14,50 SAY dg_p10
      CLEAR GETS
ENDCASE
*
RETURN
* EOP set_if2 ********************************************************


PROCEDURE set_if3
* Called from setup
*
DO CASE
   CASE CHR(dl_i) $ [jJ]
      @ 16, 9 SAY dg_p11
      @ 16,57 GET dl_rule1
      @ 16,70 GET dl_rule
      @ 23, 9 SAY "Ruler line is same length as screen-form " +;
                  "COLumns in <C> above."
      READ
      SET COLOR TO &dg_normal
      @ 16, 9 SAY dg_p11
      @ 16,57 GET dl_rule1
      CLEAR GETS
   CASE CHR(dl_i) $ [kK]
      @ 18, 9 SAY dg_p12
      @ 23,25 SAY "Left delimiter cannot be blank."
      DO WHILE dl_istrap
         @ 18,55 GET dl_delim
         READ
         dl_istrap = dl_delim = [ ]
      ENDDO
      SET COLOR TO &dg_normal
      @ 18, 9 SAY dg_p12
   CASE CHR(dl_i) $ [lL]
      @ 19, 9 SAY dg_p13
      @ 19,72 GET dl_char PICTURE "###" RANGE 1,255
      @ 23,29 SAY "ASCII range is 1..255."
      READ
      SET COLOR TO &dg_normal
      @  2, 0 SAY REPLICATE(CHR(dl_char),80)
      @ 19, 9 SAY dg_p13
      @ 21, 0 SAY REPLICATE(CHR(dl_char),80)
   CASE CHR(dl_i) $ [mM]
      @ 20, 9 SAY dg_p14
      @ 22,12 SAY "Filename can be up to eight characters " +;
                  "with no extension."
      @ 23, 7 SAY "Set operating system path if located in " +;
                  "another drive or directory."
      DO WHILE dl_istrap
         @ 20,66 GET dl_wp PICTURE [AXXXXXXX]
         READ
         dl_istrap = dl_wp = [ ] .OR. [.] $ dl_wp
      ENDDO
      SET COLOR TO &dg_normal
      @ 20, 9 SAY dg_p14
ENDCASE
*
RETURN
* EOP set_if3 ********************************************************


PROCEDURE wait_msg
* Called from crea_new, generate, mem_gen
PARAMETERS dl_part
*
IF dl_part = 1
   @ 11,21 SAY "This takes a moment, please be patient."
**   @ 22,25 SAY "Press the Escape key to abort."
**   ON ESCAPE DO abort WITH dl_abortf
   * dl_abortf is initialized and ON ESCAPE is restored
   * in the calling program.
ELSE
   @ 11,21
ENDIF
*
RETURN
* EOP wait_msg *****************************************************


PROCEDURE writer
* Called from pars_lit, pars_var
*
PARAMETERS dl_str, dl_column, dl_issay, dl_isquote
* Passed string has been TRIMmed and is not null [].
*
* Write the @...<coordinates> part of the command.
DO line_inc
IF dg_isreltv
   ?? [@ ] + IIF(dl_isreprt, "PROW()", "ROW()") + IIF(dl_atrow = dl_lastrow,;
      IIF(dl_atrow-dl_lastrow<10, [   ], [    ]),;
      "+" +STR(dl_atrow-dl_lastrow,2)) + [,] + STR(dl_column-1,dg_max)
ELSE
   ?? [@ ] + STR(dl_atrow,dg_max) + [,] + STR(dl_column-1,dg_max)
ENDIF
*
* Write the expression part of the command.
IF dl_issay .AND. dl_isquote
   * It's a literal prompt.
   IF LEN(dl_str) <= 60
      ?? [ SAY "] + dl_str + ["]
   ELSE
      * Break long string every 40 columns.
      ?? [ SAY "] + SUBSTR(dl_str, 1,40) + [" +;]
      dl_str = SUBSTR(dl_str,41)
      DO WHILE LEN(dl_str) > 40
         DO line_inc
         ?? IIF(dg_isreltv, [                  "], [            "]) +;
            SUBSTR(dl_str, 1,40) + [" +;]
         dl_str = SUBSTR(dl_str,41)
      ENDDO
      *
      DO line_inc
      ?? IIF(dg_isreltv, [                  "], [            "]) +;
         dl_str + ["]
   ENDIF
ELSE
   * It's a variable name.
   ?? IIF(dl_issay .OR. dl_isreprt, [ SAY ], [ GET ]) + dl_str
ENDIF
*
RETURN
* EOP writer **********************************************************

* CLIPPER FUNCTION DEFINITIONS:

FUNCTION RTRIM
PARAMETERS cl_string
RETURN TRIM(cl_string)

FUNCTION RECCOUNT
RETURN LASTREC()

FUNCTION MAX
PARAMETERS cl_1, cl_2
RETURN IF(cl_1 > cl_2, cl_1, cl_2)

FUNCTION MOD
PARAMETERS cl_m1, cl_m2
cl_result = cl_m1 - INT(cl_m1/cl_m2) * cl_m2
RETURN IF(cl_result < 0, cl_result = cl_m2-1, cl_result)

FUNCTION FOUND
RETURN .NOT. EOF()

* \\\ Do not need because FIELD is an abbreviation of FIELDNAME.
* FUNCTION FIELD
* PARAMETERS cl_fldno
* RETURN FIELDNAME(cl_fldno)

FUNCTION LEFT
PARAMETERS cl_string, cl_len
RETURN SUBSTR(cl_string, 1, cl_len)

FUNCTION RIGHT
PARAMETERS cl_string, cl_len
RETURN SUBSTR(cl_string, LEN(cl_string)-cl_len+1)

FUNCTION LTRIM
PARAMETERS cl_string
DO WHILE SUBSTR(cl_string,1,1) = [ ]
   cl_string = SUBSTR(cl_string,2)
ENDDO
RETURN cl_string

FUNCTION OS
RETURN "MS/PC-DOS"

FUNCTION ISCOLOR
RETURN .F.

FUNCTION IIF
PARAMETERS iif_1, iif_2, iif_3
RETURN IF(iif_1, iif_2, iif_3)

FUNCTION DBF
RETURN IF([]<FIELDNAME(1),"DBF",[])

* EOF: dg_clip.prg \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\